home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-02 / tptc16.zip / TPTC.PAS < prev   
Pascal/Delphi Source File  |  1993-01-04  |  14KB  |  466 lines
  1.  
  2. (*
  3. todo:
  4.    -- in var params, passing address of pointer
  5.    -- two dimensional arrays, typed constants, see test.pas
  6.    -- array[a,b...] and array[a] of array... not translated
  7.    -- process subscripted (full lvalue) for fd's in read/write
  8.    -- translate 'str' and 'val'
  9.    -- string returning procedures translated to char * return
  10.    -- string (pointer to array) var parameters translated to char *
  11.    -- pointer deref does not determine lvalue type (i.e. xxx->m should
  12.       detect string types)
  13.    -- writeln strings:  'literal',^M^J,'another'
  14.    -- nested variable sharing not proper
  15.         procedure ordering
  16.         outer local decl's not prefixed
  17.    -- variant records not translated
  18.    -- untyped parameter variables
  19.    -- absolute variables
  20.  
  21. manual translations:
  22.    -- nested procedure ordering
  23.    -- atoi macro clash ?
  24.  
  25. changes
  26.    -- turbo-c procedure declaration syntax
  27.    -- arrays subscripted by enumeration types
  28.    -- fails to handle null else clause in case statement
  29.    -- include intermediate cases in swith() .. case x..y
  30.    -- pointer/var parameter translation *id.mem should be id->mem
  31.    -- pointer/var parameter translation *id[n] should be id[n]
  32.    -- concat(...)+char and string+char not detected as string/character
  33.         concat operation.
  34.    -- detect concat(concat... and replace with a sprintf variant
  35.  
  36. -- changed sprintf calls to sbld calls to preserve sources during build
  37. -- pos(c,str) and pos(str,str) are now separately translated
  38.  
  39. -- added 'base' to symbol table; use to add base-subscript offset
  40.    in all subscript references.
  41. -- moved typename translations to tpcmac.h header
  42. -- fixed bug in non-translation of tshell directives
  43. -- forward pointer declarations
  44. -- translate inline into asm statements
  45. -- complete forward translation
  46.  
  47. ---------------
  48. 13-oct-87
  49. -- improved string and array parameter translations
  50. -- string returns are now translated into char *
  51.  
  52. 15-oct-87
  53. -- corrected error in typed constant translation where nested
  54.    records are initialized.
  55. -- variant record declarations are translated into unions
  56.    but no variant expression translations are done.
  57. -- changed nested procedure error messages to include procedure name.
  58.  
  59.  
  60. (*
  61.  *
  62.  * TPTC - Turbo Pascal to C translator
  63.  *
  64.  * S.H.Smith, 9/9/85  (rev. 2/13/88)
  65.  *
  66.  * Copyright 1986, 1987 by Samuel H. Smith;  All rights reserved.
  67.  *
  68.  *
  69.  * Revision history
  70.  * ----------------
  71.  *
  72.  *   09/09/85  v0.0  (paspp)
  73.  *      Initial coding by Samuel H. Smith.  Never released.
  74.  *
  75.  *   12/19/86  v1.0
  76.  *      First distributed as TPC10 under shareware concept.
  77.  *
  78.  *   04/15/87  v1.1
  79.  *      Corrected handling of unary minus.
  80.  *      Improved error messages; added error messages to object file.
  81.  *      Added handler for integer subrange types.
  82.  *      Added handling for goto statement and numeric labels.
  83.  *      The macro header, tpcmac.h, now contains more declarations.
  84.  *      Distributed as TPC11.
  85.  *
  86.  *   04/22/87  v1.2
  87.  *      Corrected an error that led to a crash on lines with more than 40
  88.  *      leading spaces.  Distributed as TPC12.
  89.  *
  90.  *   05/20/87  v1.3
  91.  *      Added support for pascal/MT+:  external procedures and variables,
  92.  *      special write/read indirect syntax, & and ! operators,
  93.  *      default string size for string declarations.
  94.  *      Distributed as TPC13.
  95.  *
  96.  *   05/26/87  v1.4
  97.  *      Additional support for pascal/MT+.   The translator "shifts" into a
  98.  *      MT+ specific mode when it recognizes the 'MODULE' statement.
  99.  *      The '|' operator is recognized for bitwise OR.
  100.  *      The '\', '?' and '~' operators are all translated into a unary
  101.  *      not (is this right, Noam?).
  102.  *      Read(ln) and Write(ln) now support the special case of "[]" for the
  103.  *      I/O routine.
  104.  *      Long integer literals are translated from '#nnn' to 'nnnL'
  105.  *
  106.  *   06/01/87  v1.5
  107.  *      Added new ','nd-line parser.
  108.  *      Added -lower option to map identifiers to lower case.
  109.  *      Added -mt option to force pascal/mt+ mode.
  110.  *      Added partial var-parameter translation.
  111.  *      Mem, MemW, Port and PortW are all translated into Turbo C.
  112.  *      Turbo-c procedure declaration syntax is now used.
  113.  *      Arrays may now be subscripted by enumeration types.
  114.  *      Null else clause now handled properly in IF and CASE statements.
  115.  *      For .. downto is now translated correctly.
  116.  *      The VAL..VAL form is now translated in case statements.
  117.  *
  118.  *)
  119.  
  120. {$R+}    {Range checking off}
  121. {$B+}    {Boolean complete evaluation on}
  122. {$S+}    {Stack checking on}
  123. {$I+}    {I/O checking on}
  124. {$N-}    {No numeric coprocessor}
  125. {$V-}    {Relax string rules}
  126. {$M 65500,16384,655360} {Turbo 3 default stack and heap}
  127.  
  128.  
  129. program translate_tp_to_c;
  130.  
  131. uses Crt;
  132.  
  133. const
  134.    version1 =     'TPTC - Translate Pascal to C';
  135.    version2 =     'Version 1.6, 2/8/88 S.H.Smith';
  136.    maxparam =     20;         {max number of parameters to process}
  137.    identlen =     12;         {nominal length of identifiers}
  138.    maxnest =      6;          {maximum procedure nesting}
  139.    nestfile =     'nest$';    {scratchfile for nested procedures}
  140.    localseprt =   '__S__';    {local sym table nesting separating string}
  141.  
  142. type
  143.    anystring =    string [127];
  144.    string255 =    string [255];
  145.    string80  =    string [80];
  146.    string40  =    string [40];
  147.    string20  =    string [20];
  148.    string10  =    string [10];
  149.  
  150.    toktypes =     (number,      identifier,
  151.                    strng,       keyword,
  152.                    unknown);
  153.  
  154.    symtypes =     (s_int,       s_long,
  155.                    s_double,    s_string,
  156.                    s_char,      s_struct,
  157.                    s_file,      s_void   );
  158.  
  159.    supertypes =   (ss_scalar,   ss_const,
  160.                    ss_func,     ss_struct,
  161.                    ss_array              );
  162.  
  163.    symptr =      ^symrec;
  164.    symrec =       record
  165.                      symtype:  symtypes;        { simple type }
  166.                      suptype:  supertypes;      { scalar,array etc. }
  167.                      id:       string40;        { name of entry }
  168.                      parcount: integer;         { parameter count }
  169.                      pvar:     integer;         { var/val reference }
  170.                      base:     integer;         { base value for subscripts }
  171.                      limit:    integer;         { limiting value for scalars }
  172.                      parent:   symptr;
  173.                      next:     symptr;
  174.                   end;
  175.  
  176.    paramlist =    record
  177.                      n:      integer;
  178.                      id:     array [1..maxparam] of string80;
  179.                      stype:  array [1..maxparam] of symtypes;
  180.                      sstype: array [1..maxparam] of supertypes;
  181.                   end;
  182.  
  183. const
  184.  
  185.    (* names of symbol types *)
  186.    typename:  array[symtypes] of string40 =
  187.                   ('int',       'long',
  188.                    'double',    'char *',
  189.                    'char',      'struct',
  190.                    'file',      'void');
  191.  
  192.    supertypename:  array[supertypes] of string40 =
  193.                   ('Scalar',    'Constant',
  194.                    'Function',  'Structure',
  195.                    'Array'                   );
  196.  
  197.  
  198.    (* these words start new statements or program sections *)
  199.    nkeywords = 12;
  200.    keywords:  array[1..nkeywords] of string40 = (
  201.       'PROGRAM',   'PROCEDURE', 'FUNCTION',
  202.       'VAR',       'CONST',     'TYPE',
  203.       'LABEL',     'OVERLAY',   'FORWARD',
  204.       'MODULE',    'EXTERNAL',  'CASE');
  205.  
  206.  
  207. var
  208.    con:           text;
  209.    ltok:          string80;
  210.    tok:           string80;
  211.    toktype:       toktypes;
  212.  
  213.    infd:          text;
  214.    inclfd:        text;
  215.    incl_name:     string[64];
  216.    read_include:  boolean;
  217.  
  218.    nextc:         char;
  219.  
  220.    spaces:        anystring;
  221.    extradot:      boolean;
  222.    nospace:       boolean;
  223.  
  224.    unitlevel:     integer;
  225.  
  226.    globals:       symptr;
  227.    locals:        symptr;
  228.  
  229.    curtype:       symtypes;
  230.    cursuptype:    supertypes;
  231.    curlimit:      integer;
  232.  
  233.    srclines:      array [1..maxnest] of integer;
  234.    srcfiles:      array [1..maxnest] of string40;
  235.  
  236.    ofd:           array[1..maxnest] of text;
  237.    level:         integer;
  238.  
  239.    in_locals:     boolean;
  240.    past_marker:   boolean;
  241.    in_globals:    boolean;
  242.    nestn:         string10;
  243.  
  244.    mt_plus:       boolean;   {true if translating Pascal/MT+}
  245.    map_lower:     boolean;   {true to map idents to lower case}
  246.    dumpsymbols:   boolean;   {dump tables to object file}
  247.    includeinclude:boolean;   {include include files in output}
  248.  
  249.  
  250. {$I \tinc\ljust.inc}     {left justify writeln strings}
  251. {$I \tinc\atoi.inc}      {ascii to integer conversion}
  252. {$I \tinc\ftoa.inc}      {float to ascii conversion}
  253. {$I \tinc\stoupper.inc}  {map string to upper case}
  254.  
  255.  
  256. procedure gettok;              forward;
  257. procedure pblock;              forward;
  258. procedure pstatement;          forward;
  259. procedure punit;               forward;
  260. procedure pvar;                forward;
  261. function  plvalue: string255;  forward;
  262. function  pexpr:   string255;  forward;
  263. procedure pident;              forward;
  264. procedure exit_nested;         forward;
  265. procedure enter_nested;        forward;
  266. procedure discard_nested;      forward;
  267.  
  268. (********************************************************************)
  269.  
  270. {$I tpcsym.inc}          {symbol table handler}
  271. {$I tpcmisc.inc}         {misc functions}
  272. {$I tpcscan.inc}         {scanner; lexical analysis}
  273. {$I tpcexpr.inc}         {expression parser and translator}
  274. {$I tpcstmt.inc}         {statement parser and translator}
  275. {$I tpcdecl.inc}         {declaration parser and translator}
  276. {$I tpcunit.inc}         {program unit parser and translator}
  277.  
  278.  
  279. (********************************************************************)
  280. procedure init;
  281.    {initializations before translation can begin}
  282.  
  283.    procedure enter(name: anystring; etype: symtypes);
  284.    begin
  285.       newsym(name, etype, ss_scalar, -1, 0, 0);
  286.    end;
  287.  
  288. begin
  289.    spaces := '';
  290.    nospace := false;
  291.    ltok := '';
  292.    tok := '';
  293.    toktype := unknown;
  294.    extradot := false;
  295.    srclines[level] := 0;
  296.    unitlevel := 0;
  297.    globals := nil;
  298.    locals := nil;
  299.    curtype := s_void;
  300.    cursuptype := ss_scalar;
  301.    read_include := false;
  302.    nestn := '00';
  303.  
  304.    newsym('argv', s_string, ss_array, -1, 0, 0);
  305.    enter('argc',  s_int);
  306.    enter('con',   s_file);
  307.    enter('kbd',   s_file);
  308.    enter('lst',   s_file);
  309.    enter('output',s_file);
  310.    enter('input', s_file);
  311.    enter('aux',   s_file);
  312. end;
  313.  
  314.  
  315. (********************************************************************)
  316. procedure usage(why: anystring);
  317.    {print usage instructions and copyright}
  318. begin
  319.    writeln('Copyright 1986, 1987 by Samuel H. Smith;  All rights reserved.');
  320.    writeln;
  321.    writeln('Please refer all inquiries to:');
  322.    writeln('    Samuel H. Smith          The Tool Shop BBS');
  323.    writeln('    5119 N 11 Ave 332         (602) 279-2673');
  324.    writeln('    Phoenix, AZ 85013');
  325.    writeln;
  326.    writeln('You may copy and distribute this program freely, provided that:');
  327.    writeln('    1)   No fee is charged for such copying and distribution, and');
  328.    writeln('    2)   It is distributed ONLY in its original, unmodified state.');
  329.    writeln;
  330.    writeln('If you like this program, and find it of use, then your contribution');
  331.    writeln('will be appreciated.  If you are using this product in a commercial');
  332.    writeln('environment then the contribution is not voluntary.');
  333.    writeln;
  334.  
  335.    write('Press enter: ');
  336.    readln;
  337.  
  338.    writeln;
  339.    writeln;
  340.    writeln('Error:  ',why);
  341.    writeln;
  342.    writeln(
  343.      'Usage:  TPTC input_file [output_file] [-lower] [-mt] [-dump] [-include]');
  344.    writeln;
  345.    writeln('Where:');
  346.    writeln('  input_file     specifies the main source file, .PAS default');
  347.    writeln('  output_file    specifies the output file, .C default');
  348.    writeln('  -lower         map all identifiers to lower case');
  349.    writeln('  -mt            use Pascal/MT+ specific translations');
  350.    writeln('  -dump          Dump symbols');
  351.    writeln('  -include       output include files'' contents');
  352.    writeln;
  353.    writeln('Example:');
  354.    writeln('  tptc fmap -lower -dump');
  355.    writeln;
  356.    halt;
  357. end;
  358.  
  359.  
  360.  
  361. (* main program *)
  362.  
  363. var
  364.    inname:   anystring;
  365.    outname:  anystring;
  366.    par:      anystring;
  367.    i:        integer;
  368.  
  369. begin
  370.    assign(con,'');
  371.    rewrite(con);
  372.  
  373.    writeln(con);
  374.    writeln(con,version1);
  375.    writeln(con,'   ',version2);
  376.    writeln(con);
  377.  
  378. (* get command line options, if any *)
  379.  
  380.    outname := '';
  381.    inname := '';
  382.    map_lower := false;
  383.    mt_plus := false;
  384.    dumpsymbols := false;
  385.    includeinclude := false;
  386.  
  387.    for i := 1 to paramcount do
  388.    begin
  389.       par := paramstr(i);
  390.  
  391.       if par[1] = '-' then
  392.       begin
  393.          if par = '-lower' then
  394.             map_lower := true
  395.          else
  396.          if par = '-mt' then
  397.             mt_plus := true
  398.          else
  399.          if par = '-dump' then
  400.             dumpsymbols := true
  401.          else
  402.          if par = '-include' then
  403.             includeinclude := true
  404.          else
  405.             usage('invalid option');
  406.       end
  407.       else
  408.  
  409.       if inname = '' then
  410.          inname := par
  411.       else
  412.  
  413.       if outname = '' then
  414.          outname := par
  415.       else
  416.          usage('duplicate input/output name');
  417.    end;
  418.  
  419.    if inname = '' then
  420.       usage('missing input name');
  421.  
  422.    if outname = '' then
  423.       outname := inname;
  424.  
  425.    if pos('.',inname) = 0 then
  426.       inname := inname + '.pas';
  427.  
  428.    if inname = outname then
  429.       usage('duplicate input/output name');
  430.  
  431.    assign(infd,inname);
  432.    srcfiles[1] := inname;
  433.    {$I-} reset(infd); {$I+}
  434.    if ioresult <> 0 then
  435.    begin
  436.       writeln(con,'Can''t open input file: ',inname);
  437.       halt;
  438.    end;
  439.  
  440.    if pos('.',outname) = 0 then
  441.       outname := outname + '.c';
  442.  
  443.    level := 1;
  444.    assign(ofd[level],outname);
  445. {$I-}
  446.    rewrite(ofd[level]);
  447. {$I+}
  448.    if ioresult <> 0 then
  449.    begin
  450.       writeln(con,'Can''t open output file: ',outname);
  451.       halt;
  452.    end;
  453.  
  454.  
  455. (* do initializations *)
  456.    init;
  457.  
  458. (* process the source file(s) *)
  459.    pprogram;
  460.    purgetable(globals);
  461.  
  462.    writeln(con,srclines[level]' lines           ');
  463.    close(ofd[level]);
  464. end.
  465.  
  466.